home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 1.iso / ARGONET / PD / PROGRAMMING / PERL.SPK / Perl5001 / !Perl / riscos / pm / RDBM_File next >
Encoding:
Text File  |  1996-02-21  |  4.4 KB  |  146 lines
  1. package RDBM_File;
  2. use Carp;
  3. use RiscosLib;
  4.  
  5. $debug = 0;
  6.  
  7. printf "RDBM Loading\n" if $debug;
  8.  
  9. %lastkey = ();
  10. $buffer = ' 'x255;
  11. $buflen = length($buffer);
  12.  
  13. system('rmensure gdbm 0 rmload system:modules.gdbm');
  14.  
  15. # Get the SWI numbers
  16. $str="Gdbm_Open"; $Gdbm_Open = SWINumberFromString($str);
  17. $str="Gdbm_Store";$Gdbm_Store = SWINumberFromString($str);
  18. $str="Gdbm_Fetch";$Gdbm_Fetch = SWINumberFromString($str);
  19. $str="Gdbm_Exists";$Gdbm_Exists = SWINumberFromString($str);
  20. $str="Gdbm_Delete";$Gdbm_Delete = SWINumberFromString($str);
  21. $str="Gdbm_FirstKey";$Gdbm_FirstKey = SWINumberFromString($str);
  22. $str="Gdbm_NextKey";$Gdbm_NextKey = SWINumberFromString($str);
  23. $str="Gdbm_Clear";$Gdbm_Clear = SWINumberFromString($str);
  24. $str="Gdbm_Close";$Gdbm_Close = SWINumberFromString($str);
  25.  
  26. #Set up some register masks
  27. @in = (0);@out = ();$ocmask = ®mask(\@in,\@out);
  28. @in = (0..4);@out = ();$sfmask = ®mask(\@in,\@out);
  29. @in = (0..2);@out = ();$edmask = ®mask(\@in,\@out);
  30.  
  31. #Set up a default work directory
  32. $workdir = '<PerlArchLib$Dir>.work.rdbm.'; # Directory used if no pathname for the database
  33.  
  34. print "RDBM initialisation completed\n" if $debug;
  35.  
  36. sub TIEHASH  {
  37.     print "In TIEHASH, package is $_[0], database is $_[1]\n" if $debug;
  38.     my $file = $_[1];
  39.     my $pathname;
  40.     my @path = split( m@\.@, $file);
  41.     $file = pop(@path);
  42.     if ( @path ) {
  43.         $pathname = join('.', @path ).'.';
  44.     } else {
  45.         $pathname = $workdir;
  46.     }
  47.     $file = $pathname.$file;
  48.         my $handle = syscall($Gdbm_Open,$ocmask,$file) || croak ("Can't open database $file");
  49.     my $self = \$handle;
  50.     bless $self;
  51. }
  52.  
  53. sub STORE    {
  54.     print "In STORE, storing in database ${$_[0]}:\-   $_[1] : $_[2]\n" if $debug;
  55.     my $handle = ${$_[0]};
  56.     my $key = $_[1]; my $keylen = length($key);
  57.     my $value = $_[2]; my $vallen = length($value);
  58.     syscall($Gdbm_Store,$sfmask,$handle,$key,$keylen,$value,$vallen);
  59. }
  60.  
  61. sub FETCH    {
  62.     print "In FETCH, finding value for $_[1] in database ${$_[0]}\n " if $debug;
  63.     my $handle = ${$_[0]};
  64.     my $key = $_[1]; my $keylen = length($key);
  65.     my $itemlen = syscall($Gdbm_Fetch,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
  66.     carp("No such item") if ($itemlen == -1);
  67.     if ( $itemlen > $buflen ) {
  68.         warn "Buffer extended" if $debug;
  69.         $buffer = ' ' x $itemlen;
  70.         $buflen = $itemlen;
  71.         $itemlen = syscall($Gdbm_Fetch,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
  72.     }
  73.     substr($buffer, 0, $itemlen);
  74. }
  75.  
  76. sub EXISTS   {
  77.     print "In EXISTS, finding value for $_[1] in database ${$_[0]}\n " if $debug;
  78.     my $handle = ${$_[0]};
  79.     my $key = $_[1]; my $keylen = length($key);
  80.     syscall($Gdbm_Exists,$edmask,$handle,$key,$keylen);
  81. }
  82.  
  83. sub DELETE   {
  84.     print "In DELETE, deleting value for $_[1] in database ${$_[0]}\n " if $debug;
  85.     my $handle = ${$_[0]};
  86.     my $key = $_[1]; my $keylen = length($key);
  87.     # DELETE should return deleted value, so we have to fetch it
  88.     my $itemlen = syscall($Gdbm_Fetch,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
  89.     carp("No such item") if ($itemlen == -1);
  90.     if ( $itemlen > $buflen ) {
  91.         warn "Buffer extended" if $debug;
  92.         $buffer = ' ' x $itemlen;
  93.         $buflen = $itemlen;
  94.         $itemlen = syscall($Gdbm_Fetch,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
  95.     }
  96.     syscall($Gdbm_Delete,$edmask,$handle,$key,$keylen);
  97.     substr($buffer, 0, $itemlen);
  98. }
  99.  
  100. sub FIRSTKEY {
  101.     print "In FIRSTKEY, database ${$_[0]}\n " if $debug;
  102.     my $handle = ${$_[0]};
  103.     $itemlen = syscall($Gdbm_FirstKey,$edmask,$handle,$buffer,$buflen);
  104.     return undef if ($itemlen == -1);
  105.     if ( $itemlen > $buflen ) {
  106.         warn "Buffer extended" if $debug;
  107.         $buffer = ' ' x $itemlen;
  108.         $buflen = $itemlen;
  109.         $itemlen = syscall($Gdbm_FirstKey,$edmask,$handle,$buffer,$buflen);
  110.     }
  111.     $lastkey{$handle} = substr($buffer, 0, $itemlen);
  112. }
  113.  
  114. sub NEXTKEY  {
  115.     print "In NEXTTKEY, database ${$_[0]}\n " if $debug;
  116.     my $handle = ${$_[0]};
  117.     my $key = $lastkey{$handle}; my $keylen = length($key);
  118.     $itemlen = syscall($Gdbm_NextKey,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
  119.     return undef if ($itemlen == -1);
  120.     if ( $itemlen > $buflen ) {
  121.         warn "Buffer extended" if $debug;
  122.         $buffer = ' ' x $itemlen;
  123.         $buflen = $itemlen;
  124.         $itemlen = syscall($Gdbm_NextKey,$sfmask,$handle,$key,$keylen,$buffer,$buflen);
  125.     }
  126.     $lastkey{$handle} = substr($buffer, 0, $itemlen);
  127. }
  128.  
  129. sub CLEAR    {
  130.     print "In CLEAR, database ${$_[0]}\n " if $debug;
  131.     my $handle = ${$_[0]};
  132.     syscall($Gdbm_Clear,$ocmask,$handle);
  133. }
  134.  
  135. sub DESTROY    {
  136.     print "DESTROY called for ${$_[0]}\n" if $debug;
  137.     my $handle = ${$_[0]};
  138.     # I don't think we want actually to delete the database, just close it
  139.     syscall($Gdbm_Close,$ocmask,$handle);
  140. }
  141.  
  142. 1;
  143.  
  144. __END__
  145.  
  146.